module LLVM.Parser.File.FileParser where

import LLVM.Parser.Bits.BitGet
import LLVM.Parser.Record.Parser
import LLVM.Parser.Record.Record
import LLVM.Parser.Block.BlockParser
import LLVM.Util

import LLVM.Parser.Bits.Primitives
import LLVM.Parser.Record.TreeGenerator.Instances

import Control.Monad
import Control.Monad.Error
import Control.Monad.State

import Data.ByteString as B
import Numeric

import Data.List
import Data.Char

import System.Environment( getArgs )

import Data.TreeLike
import Data.Tree
import Data.Bits (Bits(..))
import LLVM.Code.Module (Module(..))
import Data.Maybe (fromJust)
import LLVM.Code.PPrint (PPrintable(..))


import Text.JSON.Generic(encodeJSON)

readMagic :: ErrParser ()
readMagic = do
                 b <- liftErr getWord8
                 c <- liftErr getWord8
                 code0 <- liftErr $ getAsWord8 4
                 code1 <- liftErr $ getAsWord8 4
                 code2 <- liftErr $ getAsWord8 4
                 code3 <- liftErr $ getAsWord8 4
                 unless (b == 0x42 &&
                         c == 0x43 &&
                         code0 == 0x0 &&
                         code1 == 0xC &&
                         code2 == 0xE &&
                         code3 == 0xD)
                        (throwError "Error while parsing file magic numbers")
                 return ()

readBitCode :: ErrParser [RawBlockElem]
readBitCode = do
                 readMagic
                 sc  <- readScatter
                 return sc


prettyPrintBH :: BlockHeader -> String
prettyPrintBH bh = case (blockId bh) of
                        8  -> "LLVM Module: " ++ sizeinfo
                        9  -> "Parameter attributes: " ++ sizeinfo
                        10 -> "Type(deprecated): " ++ sizeinfo
                        11 -> "Constants: " ++ sizeinfo
                        12 -> "Function: " ++ sizeinfo
                        13 -> "Type symbol table: " ++ sizeinfo
                        14 -> "Value symbol table: " ++ sizeinfo
                        15 -> "Metadata: " ++ sizeinfo
                        16 -> "Metadata attachments: " ++ sizeinfo
                        17 -> "Type(new): " ++ sizeinfo
                        id -> "Unknown bitcode block #" ++ show id ++ ": " ++ sizeinfo
                   where sizeinfo = (show $ blockSize bh * 4) ++ " bytes"

prettyPrintRecord :: RawRecord -> String
prettyPrintRecord rec = case (recId rec) of
                             0 -> "Block closure"
                             1 -> "Block entry"
                             2 -> "Abbreviation definition"
                             otherwise -> prettyPrintCustom $ recordAsList rec

prettyPrintCustom :: [Integer] -> String
prettyPrintCustom (_:h:t) = "Custom record with code " ++ show h ++ " and data " ++ show t



prettyPrintRecordComplex :: BlockHeader -> RawRecord -> String
prettyPrintRecordComplex bh r = case (blockId bh) of
                        8 -> case (recordAsList r) of -- module
                                  (_:1:v:_) -> "Version " ++ show v
                                  (_:2:str) -> "Code module triple: " ++ massOrd str
                                  (_:3:str) -> "Data layout: " ++ massOrd str
                                  (_:4:str) -> "Module asm: " ++ massOrd str
                                  (_:5:str) -> "Code section: " ++ massOrd str
                                  (_:6:str) -> "Dep lib: " ++ massOrd str
                                  (_:7:str) -> "Global var def: " ++ "TODO"
                                  (_:8:str) -> "Function def: " ++ "TODO" ++ show str
                                  (_:9:str) -> "Alias: " ++ "TODO"
                                  (_:10:val:_) -> "Purge vals index: " ++ show val
                                  (_:11:str) -> "Garbage collector name: " ++ massOrd str
                                  otherwise -> prettyPrintRecord r
                        9 ->  case (recordAsList r) of -- parameter attribs
                                  (_:1:_) -> "Parameter attributes entry"
                                  otherwise -> prettyPrintRecord r
                        x | (x == 10 || x == 17) 
                          -> case (recordAsList r) of -- type table
                                  (_:1:v:_) -> "Number of entries: " ++ show v
                                  (_:2:_) -> "void"
                                  (_:3:_) -> "float"
                                  (_:4:_) -> "double"
                                  (_:5:_) -> "label"
                                  (_:6:_) -> "opaque"
                                  (_:7:v:_) -> "int" ++ show v
                                  (_:8:p:sp:_) -> "pointer to type #" ++ show p ++ " in address space #" ++ show sp
                                  (_:9:vararg:_:ret:pars) -> varg
                                                                ++ "function returning type #"
                                                                ++ show ret
                                                                ++ " and taking types "
                                                                ++ show pars
                                                             where varg = if(vararg == 0) then "" else "vararg "
                                  (_:10:pk:fls) -> packed ++ "struct of types " ++ show fls
                                                   where packed = if(pk == 0) then "" else "packed "
                                  (_:11:sz:els:_) -> "array of size " ++ show sz ++ " holding elems of type #" ++ show els
                                  (_:13:_) -> "x86 float80"
                                  (_:14:_) -> "ppc float128"
                                  (_:15:_) -> "metadata"
                                  otherwise -> prettyPrintRecord r
                        11 -> case (recordAsList r) of -- constant table
                                   (_:1:t:_) -> "set type to type #" ++ show t
                                   (_:2:_) -> "NULL"
                                   (_:3:_) -> "undefined"
                                   (_:4:x:_) -> "integer " ++ (show $ tosigned x)
                                   (_:5:xs) -> "wide integer " ++ (show $ Prelude.map tosigned xs)
                                   (_:9:xs) -> "c string \"" ++ massOrd xs ++ "\""
                                   (_:20:xs) -> "inbound getElementPtr expression " ++ show xs
                                   otherwise -> prettyPrintRecord r
                        12 -> "Function: "++ prettyPrintRecord r
                        13 -> "Type symbol table: "++ prettyPrintRecord r
                        14 -> case (recordAsList r) of -- value symbol table, only id one, the next digit is value num
                                   (_:1:id:str) -> "Value symbol entry: value #" ++ show id ++ " is " ++ "\"" ++ massOrd str ++ "\""
                                   otherwise -> prettyPrintRecord r
                        
                            --METADATA_STRING        = 1,   // MDSTRING:      [values]
                            --2 is unused.
                            --3 is unused.
                            --METADATA_NAME          = 4,   // STRING:        [values]
                            --5 is unused.
                            --METADATA_KIND          = 6,   // [n x [id, name]]
                            --7 is unused.
                            --METADATA_NODE          = 8,   // NODE:          [n x (type num, value num)]
                            --METADATA_FN_NODE       = 9,   // FN_NODE:       [n x (type num, value num)]
                            --METADATA_NAMED_NODE    = 10,  // NAMED_NODE:    [n x mdnodes]
                            --METADATA_ATTACHMENT    = 11   // [m x [value, [n x [id, mdnode]]]
                        15 -> "Metadata: "++ 
                                case (recordAsList r) of
                                     (_:1:xs) -> "\"" ++ massOrd xs ++ "\""
                                     (_:4:xs) -> "\"" ++ massOrd xs ++ "\""
                                     (_:6:id:xs) ->  "#" ++ show id ++ ": \"" ++ massOrd xs ++ "\""  
                                     (_:8:vals) -> show $ pairs vals
                                     (_:9:vals) -> show $ pairs vals
                                     (_:10:vals) -> show $ pairs vals
                                     _ -> "Unknown meta: " ++ prettyPrintRecord r
                        16 -> "Metadata attachments: "++ prettyPrintRecord r
                        otherwise -> prettyPrintRecord r

readFromIO :: FilePath -> IO (MayError [RawBlockElem])
readFromIO f = do
                bs <- B.readFile f
                return $ evalParser bs readBitCode


validateFile :: FilePath -> IO String
validateFile f = do
                   bl <- readFromIO f
                   case (bl) of (Left mes) -> return mes
                                (Right elems) ->
                                    return $ showBCcontents elems ++ (pprint $ readModule elems)

readModule :: [RawBlockElem] -> Module
readModule ((Sub rb):_) = fromJust $ fromRawBlock rb
readModule _ = error "Illegal module"

ioReadModule :: FilePath -> IO Module
ioReadModule f = do
                    bl <- readFromIO f
                    case (bl) of
                         (Left mes) -> error mes
                         (Right elems) -> return $ readModule elems

showBCcontents elems = "\n\n" ++ (drawForest $ tlmapl prettyPrintRecordComplex prettyPrintBH hdr elems)
                       where hdr = virtualDefaultHeader


puts = Prelude.putStrLn

runValidation :: IO ()
runValidation = do
                   args <- getArgs
                   case args of
                        [] -> do
                                 puts "LLVM parser test program"
                                 puts "Usage: validate %args%"
                        _  -> flip mapM_ args $ \fname ->
                                do
                                   puts fname
                                   ret <- validateFile $ fname
                                   puts ret

convertFileToJSON :: FilePath -> IO String
convertFileToJSON f = do
                          bl <- readFromIO f
                          case (bl) of 
                               (Left mes) -> return mes
                               (Right elems) ->
                                    return $ encodeJSON $ readModule elems

runJSConversion :: IO ()
runJSConversion = do
                   args <- getArgs
                   case args of
                        [] -> do
                                 puts "LLVM parser test program"
                                 puts "Usage: ssa2json %args%"
                        _  -> flip mapM_ args $ \fname ->
                                do
                                   ret <- convertFileToJSON fname
                                   puts ret

--tstDmp :: ErrParser String
--tstDmp = do
--                readMagic
--                b <- liftErr $ getFBR 2
--                c <- liftErr $ getVBR 8
--                d <- liftErr $ getVBR 4
--                liftErr $ getAlign32
--                e <- liftErr $ getFBR 32
--                return $ show [showHex b "",showHex c "",showHex d "",showHex e ""]

tstDmp :: ErrParser String
tstDmp = do
                readMagic
                fst <- readRecord
                let br = fromRawRecord fst :: Maybe BlockHeader
                head <- promoteMaybe br "First record is not a header"
                assumeBlockHead head
                snd <- readRecord
                let br2 = fromRawRecord snd :: Maybe BlockHeader
                head2 <- promoteMaybe br2 "Second record is not a header"
                assumeBlockHead head2
                smth <- lift $ get
                return $ show (show smth)



tstDmpv bs = case (evalParser bs tstDmp) of
               (Left mes) -> return mes
               (Right v) -> return v

runValidation' :: IO ()
runValidation' = do
                   args <- getArgs
                   Prelude.putStrLn $ args !! 0
                   bs <- B.readFile $ args !! 0
                   ret <- tstDmpv bs
                   Prelude.putStrLn ret
                   return ()
